perm filename EMACLS.19[MAC,LSP]2 blob
sn#688802 filedate 1982-11-29 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00026 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MacLisp portion of the E/MacLisp Interface.
C00022 00003 Routines to queue up mail
C00025 00004 αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
C00028 00005 Mail Interface
C00033 00006 Interrupt Defer
C00034 00007 Mail Type
C00038 00008 Wait Mail
C00042 00009 Mask Routines
C00044 00010 Mail SFA
C00047 00011 Tyi
C00050 00012 Tyo
C00053 00013 Force Output
C00056 00014 Message Align
C00059 00015 Mail Refresh
C00060 00016 Transfer Buffer
C00066 00017 Clear Input
C00067 00018 Wait OK
C00070 00019 Send Simple Message
C00072 00020 Em:init
C00075 00021 Send OK
C00076 00022 Em:eval-protect
C00077 00023 Mail queue
C00081 00024 Readonly Variables
C00087 00025 Random debugging stuff
C00090 00026 Storage for Mail routines
C00095 ENDMK
C⊗;
;;; MacLisp portion of the E/MacLisp Interface.
;;;
;;; An SFA/MAIL based system for communicating with
;;; an unstructured, standard text editor.
;;; Starts with si:ejobnum figured out from E.
;;; (sfa-call <sfa> 'send-lines n)
;;; sets the number of lines that are sent at one time to n.
;;; normal is T (meaning send every line).
;;; NIL means never send.
;;; (sfa-call <sfa> 'report-send-lines) returns the value
;;; si:ecalledp, the global variable, tells whether E called you
;;; GABRIEL 7/1/82 3:42
;;; lqp has been simplified. Tyi-inited, and mailinp have been eliminated.
;;; The latter have been replaced by INBYTES and RINBYTES, which are now
;;; better kept up to date. INBYTES = 0 and RINBYTES = 1 are now the
;;; defaults for mail (readonlymail) not ready to ildb
;;; Some E type stuff moved to EAID. ADD-QUEUE now will reset the interface if
;;; there is not enough core for the arrays.
;;; GABRIEL 11/29/82 11:44 Added -em:e-buffer-address- and -em:e-word-count-
;;; which are set to the last E buffer address and E word count in a failed
;;; JOBRD.
;;; *History*
(declare (mapex t)
; (setq defmacro-for-compiling ())
(special -em:ecommands- -em:sfa- -em:errorp-
-em:oldtyi- -em:oldtyo- -em:mode- -em:silence-
-em:mail-input-buffer-dry-handler- -em:queue- -em:lqueue-
-em:herald- -em:cmchar-table- -em:si:ecalledp- si:ejobnum
-em:e-word-count- -em:e-buffer-address-
si:sail-mail-service -em:within-add-queue-
-em:filemode- -em:linel-)
(*expr em:get-next-readonly em:force-readonly-message em:make-sixbit
em:readonly-init em:warn em:message-align em:send-simple-message
em:crlf-message-align
em:mail-sfa em:init-send-lines em:init em:get-jobnum em:set-jobnum
em:turn-mask-off em:business-address em:mail-interrupt-handler
em:message-type em:mask-on em:eval-protect em:mask-off em:copy-alias1)
(*lexpr em:fread %match)
(fixnum si:ejobnum))
(eval-when (compile) (terpri msgfiles)
(princ "CHNINT & INTPDL need to be defined!" msgfiles)
(terpri msgfiles))
(setq -em:ecommands- ()
-em:mail-input-buffer-dry-handler- ()
-em:within-add-queue- ()
-em:e-word-count- 0
-em:e-buffer-address- 0
-em:mode- 'LTYPE
-em:si:ecalledp- ()
-em:oldtyi- tyi -em:oldtyo- tyo
-em:filemode- ()
-em:cmchar-table- ()
-em:herald- '|MacLisp Ready|
-em:silence- ()
-em:linel- (linel t))
(defun em:mail-interface-initialize ()
(em:turn-mask-off)
(setq -em:queue- ())
(setq -em:lqueue- ())
(em:initialize)
(setq -em:si:ecalledp- t)
(and -em:herald-
(progn (princ -em:herald-)(terpri)))
(sfa-call -em:sfa- 'force-output ())
(setq si:sail-mail-service 'em:mail-interrupt-handler)
)
(setq -em:sfa- ())
(sstatus ttyint 200. '+internal-↑b-break)
(sstatus ttyint 232. '+internal-↑b-break)
(sstatus ttyint 206. 'em:reset&↑b-break)
(sstatus ttyint 238. 'em:reset&↑b-break)
(defun em:reset&↑b-break (()())
(em:reset)
(+internal-↑b-break () ()))
(defun em:copy-alias ()
(apply `crunit `(dsk ,(em:copy-alias1))))
(defun em:initialize ()
(em:get-jobnum)
(em:init)
(em:copy-alias)
(em:init-send-lines)
(setq -em:sfa- (sfa-create (function em:mail-sfa) 0 'mail-sfa))
(setq tyi -em:sfa-)
(setq tyo -em:sfa-)
(setq msgfiles `(,-em:sfa-))
(sfa-store -em:sfa- 'xcons -em:sfa-)
(em:send-simple-message 'ok)
)
(defun em:connect (n)
(em:set-jobnum n)
(em:init)
(em:init-send-lines)
(setq -em:sfa- (sfa-create (function em:mail-sfa) 0 'mail-sfa))
(setq tyi -em:sfa-)
(setq tyo -em:sfa-)
(setq msgfiles `(,-em:sfa-))
(sfa-store -em:sfa- 'xcons -em:sfa-)
(em:send-simple-message 'ok)
)
(defmacro unascii (x)
`(car (exploden ,x)))
(defun em:naecommands (l)
(em:ecommands (append '(α - α x M A L T M O D E ⊗ ↔) L)))
(defun em:ecommands (l)
(sfa-call -em:sfa- 'force-output ())
(let ((-em:ecommands- t))
(do ((com l (cdr com)))
((null com)(sfa-call -em:sfa- 'force-output ()))
(cond ((eq (car com) '<cr>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o27))
((eq (car com) '<lf>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o1))
((eq (car com) '<sp>)
(sfa-call -em:sfa- 'tyo '32.))
((eq (car com) '<bs>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o102))
((eq (car com) '<tab>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o75))
((eq (car com) '<⊗>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o26))
((eq (car com) '<alt>)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o33))
(t
(sfa-call -em:sfa- 'tyo
(unascii (car com))))))))
;;; Like above, but takes ascii codes
(defun em:raw-ecommands (l)
(sfa-call -em:sfa- 'force-output ())
(let ((-em:ecommands- t))
(do ((com l (cdr com)))
((null com)(sfa-call -em:sfa- 'force-output ()))
(cond ((= (car com) #o11)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o75))
((= (car com) #o175)
(sfa-call -em:sfa- 'tyo #o26)
(sfa-call -em:sfa- 'tyo #o33))
(t
(sfa-call -em:sfa- 'tyo
(cond ((= (car com) #o15) #o26)
((= (car com) #o12) #o27)
(t (car com)))))))))
(defun em:set-send-lines (n)
(sfa-call -em:sfa- 'send-lines n))
(defun em:get-send-lines ()
(sfa-call -em:sfa- 'report-send-lines ()))
(defun em:force ()
(sfa-call -em:sfa- 'force-output ()))
;(setq read-eval-print-* 'em:terpri)
(defun em:terpri () (terpri -em:sfa-))
(defun em:real-terpri () (tyo #o40 -em:sfa-)(terpri -em:sfa-))
(defun em:eval-message ()
((lambda (eof)
(em:message-align)(em:set-send-lines t)
(do ((form (em:fread eof) (em:fread eof))
(l nil))
((eq form eof)
(do ((i (nreverse l) (cdr i)))
((null i)
(sfa-call -em:sfa- 'force-output ())
(em:set-send-lines ()))
(print (car i))))
(setq l (cons (eval form) l)))) (ncons ())))
(defun em:eval-message-warn ()
((lambda (eof)
(em:message-align)(em:set-send-lines t)
(do ((form (em:fread eof) (em:fread eof))
(l nil))
((eq form eof)
(em:warn '|Done!|)
(do ((i (nreverse l) (cdr i)))
((null i)
(sfa-call -em:sfa- 'force-output ())
(em:set-send-lines ()))
(print (car i))))
(setq l (cons (eval form) l)))) (ncons ())))
(defmacro em:read-until-eof (form return . forms)
`((lambda (eof)
(em:message-align)
(do ((,form (em:fread eof) (em:fread eof)))
((eq ,form eof) ,return)
. ,forms)) (ncons ())))
(defmacro em:tyi-until-eof (form return . forms)
`((lambda (-em:filemode-)
(em:message-align)
(do ((,form (tyi -em:sfa- -1) (tyi -em:sfa- -1)))
((= ,form -1) ,return)
. ,forms)) t))
(defun em:tyi-message ()
(let ((ans ()))
(em:tyi-until-eof form (nreverse ans)
(push form ans))))
(defun em:tyi-line ()
(let ((ans ()))
(em:ecommands '(α =))
(em:tyi-until-eof form (nreverse ans)
(push form ans))))
(defun em:fread n
((lambda (-em:filemode-)
(cond ((zerop n)
(read))
((= n 1)
(read (arg 1)))
((= n 2)
(read (arg 1)(arg 2)))
(t
(break |too many args to FREAD| t))))
t))
(defun em:control-dispatch (char)
(cond ((member char '(#o302 #o342))
(funcall '+internal-↑B-break -em:sfa- char))
((member char '(#o307 #o347))
(em:init)
(↑G))
((member char '(#o303 #o343))
(setq ↑D ()))
((member char '(#o304 #o344))
(setq ↑D t))
((member char '(#o322 #o362))
(em:init)(↑G))
((member char '(#o316 #o356))
(em:reset)(+internal-↑B-break ()()))
(t ((lambda (fun)
(cond (fun (funcall fun -em:sfa- char))
((setq fun (cdr (assoc char
-em:cmchar-table-)))
(funcall fun char) char)))
;(t (+internal-↑B-break () ())))) ;foo we are SUNK!!!
(status ttyint char)))))
(defun em:readonly-vars (l)
;make up message and initial (sixbit . ascii) alist
(em:readonly-init)
(cond ((> (length l) 25.)
(do ((rest l (cdr rest))
(i 25. (1- i))
(first25 ()))
((= i 0)
(append
(em:readonly-vars first25)
(em:readonly-vars rest)))
(push (car l) first25)))
(t
(setq l
(mapcar #'(lambda (x)
(subst () ()
`(,(em:make-sixbit x)
,x () ())))
l))
(em:force-readonly-message)
(do ((nxt (em:get-next-readonly)
(em:get-next-readonly))
(entry))
((equal nxt -1)
(mapcan #'(lambda (x)
(cond
((caddr x)
`((,(cadr x) . ,(cadddr x))))))
l))
(cond ((setq entry (assoc (car nxt) l))
(rplaca (cdddr entry) (cdr nxt))
(rplaca (cddr entry) t)))))))
(defun em:add-cmfun (char fun)
(push `(,char . ,fun) -em:cmchar-table-))
(defun em:delete-cmfun (char)
(setq -em:cmchar-table-
(mapcan
#'(lambda (x)
(cond ((= char (car x)) ())
(t (ncons x))))
-em:cmchar-table-)))
(defun em:ttyint (l)
(let ((entry (assoc (car l) -em:cmchar-table-)))
(cond ((cadr l)
(cond (entry (rplacd entry (cadr l))
(cadr l))
(t (em:add-cmfun (car l)(cadr l)))))
(t (cdr entry)))))
(defun em:transcript-read n
((lambda (form)
(print form)
form)
(apply 'read (listify n))))
(defun em:transcript-off (() ()) (em:transcript ()))
(defun em:transcript (flag)
(cond (flag (setq read 'em:transcript-read)
(em:ecommands '(α X L F I L E ⊗ ↔ α X E V A L ⊗ ↔ ))
(setq -em:mode- 'LFILE)
(em:swallow-alt)
'TRANSCRIPT)
(t (em:ecommands '(α X l t y p e ⊗ ↔))
(setq -em:mode- 'LTYPE)
(setq read ()))))
(defun em:swallow-alt ()
(do ((i (tyi)(tyi)))
((= i #o175) t)))
(defun em:mode (mode) (setq -em:mode- mode))
(defun em:lfile-mode () (setq -em:mode- 'lfile)
(em:ecommands
'(α X L F I L E ⊗ ↔ α X S A Y | | L F I L E | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:ltype-mode () (setq -em:mode- 'ltype)
(em:ecommands
'(α X L T Y P E ⊗ ↔ α X S A Y | | L T Y P E | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:lattach-mode () (setq -em:mode- 'lattach)
(em:ecommands
'(α X L A T T A C H ⊗ ↔ α X S A Y | | L A T T A C H | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:lpend-mode () (setq -em:mode- 'lfile)
(em:ecommands
'(α X L P E N D ⊗ ↔ α X S A Y | | L P E N D | | /m /o /d /e ⊗ ↔))
(setq -em:silence- t))
(defun em:readonly-var (var)
(cdr (assq var (em:readonly-vars `(,var)))))
(defun em:reset ()
(setq -em:sfa- ())
(setq tyi -em:oldtyi-)
(setq tyo -em:oldtyo-)
(setq msgfiles ())
(setq si:ecalledp ()))
(defun em:fail-act (x)
(cond ((and -em:within-add-queue-
(not (atom x))
(eq (car x) '*array))
(em:warn '|No core for message queueing - resetting!| )
(em:init)
(↑g))
(t (+internal-fac-break x))))
(setq fail-act 'em:fail-act)
(defun em:read () (read -em:sfa-))
(defun em:send-current ()
(em:ecommands '(α =))
(read -em:sfa-))
;;; Routines to queue up mail
;;; The queue is an ALIST of array, business address pairs
(defun em:add-queue ()
(let ((-em:within-add-queue- t))
(let ((ar (*array () 'fixnum 32.)))
(setq -em:queue-
(nconc -em:queue- `(,ar )))
(em:business-address (maknum ar)))))
(defun em:get-queue ()
(cond (-em:queue-
(prog2 ()
(em:business-address
(maknum (car -em:queue-)))
(setq -em:queue- (cdr -em:queue-))))))
(defun em:get-lqueue ()
(cond (-em:lqueue-
(prog2 ()
(em:business-address
(maknum (car -em:lqueue-)))
(setq -em:lqueue- (cdr -em:lqueue-))))))
(defun em:add-lqueue (n)
(let ((-em:within-add-queue- t))
(let ((ar (*array () 'fixnum (+ 1 n))))
(setq -em:lqueue-
(nconc -em:lqueue- `(,ar )))
(em:business-address (maknum ar)))))
(defun em:remove-tail ()
(cond (-em:queue-
(cond ((cdr -em:queue-)
(do ((l -em:queue- (cdr l))
(x (cdr -em:queue-) (cdr x)))
((null x)
(rplacd l ()))))
(t (setq -em:queue- ()))))))
(defun em:get-readonly-queue ()
(cond (-em:queue-
(cond ((eq 'readonly
(em:message-type (maknum (car -em:queue-))))
(prog1 (car -em:queue-)
(setq -em:queue- (cdr -em:queue-))))
(t (do ((l (cdr -em:queue-) (cdr l))
(x (cddr -em:queue-) (cdr x)))
((null l) ())
(cond ((eq 'readonly (em:message-type (maknum (car l))))
(prog1 (car l)
(rplacd l x))))))))))
;;; αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
;;; αnαxSLISP talks to job n(10.)
;;; α0αxSLISP types the wholine of inferior
;;; α-αxSLISP murder (i.e. negotiated suicide)
;;; α= send arrow line or attach buffer
;;; α+nα= send next n lines
;;; α-nα= send previous n lines
;;; αx= <sexp>
;;; send comand line
;;;
;;; Protocols: (* means not actually anticipated to be used; current
;;; implementation knows about it but does not send and/or interpret them
;;; specially)
;;;
;;; From E to MacLisp
;;; Mail
;;; wd0: Job# sending message
;;; wd1: type of message
;;;
;;; 2,,0: Continuation needed
;;; 1,,0: Short (fits in the next =30 words, ends with null byte
;;; or falls off)
;;;
;;; 0 no-op
;;; 1 initiating a conversation
;;; 2 ok (did the jobread)
;;; 3 SEXPs
;;; 4 explicit eof
;;; 5 control (meta) chars to follow (E macro format)
;;; (or E commands (from MacLisp to E))
;;; 6 interrupt. do <esc>i <char>
;;; 7 close connection (suicide)
;;; 8 readonly variables
;;;
;;; wd2: -number of bytes,,address of buffer
;;;
;;;
;;; E commands will be represented in the standard E macro manner
;;; (unless there is something better).
;;;
;;;
;;; Protocol is:
;;; E MacLisp
;;; ---------------
;;; initiate
;;; ok
;;;
;;; To send a short message just a MAIL
;;; To send a long message MAIL then wait for JOBREAD acknowledge
;;; To send interrupts, just send them
;;; Acknowledgment is the short OK message
;;;
;;; Commands needed:
;;; start DMP file
;;; send control chars
;;; send interrupt character (just 1 at a time)
;;;
;;; Mail Interface
(lap em:MAIL-interface subr)
(defsym LIPSAV #o10) ;LENGTH OF CRUD PUSHED BY INTERRUPT
(defsym IPSWD1 #o-7) ;WORD ONE (.PIRQC) INTERRUPTS TAKEN
(defsym IPSWD2 #o-6) ;WORD TWO (.IFPIR) INTERRUPTS TAKEN
(defsym IPSDF1 #o-5) ;SAVED .DF1
(defsym IPSDF2 #o-4) ;SAVED .DF2
(defsym IPSPC #o-3) ;SAVED PC
(defsym IPSD #o-2) ;SAVED ACCUMULATOR D
(defsym IPSR #o-1) ;SAVED ACCUMULATOR R
(defsym IPSF #o0) ;SAVED ACCUMULATOR F
(defsym rovmailblksize 50.)
(defsym mlblksize 32.)
(defsym freeac #o13)
(defsym cntrl-bit #o200)
(defsym meta-bit #o400)
(defsym ccntrlg #o307)
(defsym cntrlg #o347)
(defsym ccntrlx #o330)
(defsym cntrlx #o370)
(defsym EPR #o456062)
(defsym noutbytes #o12000)
(defsym nrovbytes #o1000)
(defsym rdblk #o2000)
(defsym blksize #o2000)
(defsym maxshort 145.)
(defsym rovmaxshort 29.)
(defsym noop-type 0)
(defsym initiate-type 1)
(defsym ok-type 2)
(defsym sexp-type 3)
(defsym explicit-eof-type 4)
(defsym ecommand-type 5)
(defsym interrupt-type 6)
(defsym kill-type 7)
(defsym readonlyvar-type 8.)
(defsym high-command 8.)
(defsym bs #o177)
(defsym lf #o12)
(defsym cr #o15)
(defsym space #o40)
(defsym tab #o11)
(defsym alpha 2)
(defsym beta 3)
(defsym cont-bit 2)
(defsym short-bit 1)
(defsym meta-mask 400)
(defsym control-mask 200)
;;; Silly jobnum was never set
setjob (movem tt ijobnum)
(movem tt ojobnum)
(movem tt o2jobnum)
(movem tt jobread)
(movem tt ljobread)
(jsp t fxcons) ;number cons
(movem a (special si:ejobnum)) ;save it
(popj p)
true (movei a 't)
(popj p)
false (movei a 'nil)
(popj p)
pfxpfalse
(move tt 1 tt)
(movem tt jobrderr)
(pop fxp tt)
(pushj p send-ok)
(movei a jobrdmess2)
(pushj p sendmess)
(move a jobrderr)
(move a (- jobrderrdispatch 1) a)
(jrst 0 sendmess)
(jrst 0 fjbrd1)
fjobrd
(move tt 1 tt)
(movem tt jobrderr)
(pushj p send-ok)
(movei a jobrdmess1)
(pushj p sendmess)
(move a jobrderr)
(move a (- jobrderrdispatch 1) a)
(pushj p sendmess)
fjbrd1
(movei a jobrdem7)
(pushj p sendmess)
(hrr tt (+ imailbox 2))
(jsp t fxcons)
(movem a (special -em:e-buffer-address-))
(movn tt inwords)
(jsp t fxcons)
(movem a (special -em:e-word-count-))
(popj p)
(entry em:get-jobnum subr)
(args em:get-jobnum (nil . 0))
(move tt (special si:ejobnum))
(movem tt ijobnum)
(movem tt ojobnum)
(movem tt o2jobnum)
(movem tt jobread)
(movem tt ljobread)
(jsp t fxcons)
(movem a (special si:ejobnum))
(jrst 0 em:get-terminal)
(entry em:set-jobnum subr)
(args em:set-jobnum (nil . 1))
(move tt 0 a)
(movem tt ijobnum)
(movem a (special si:ejobnum))
(movem tt jobread)
(movem tt ljobread)
(movem tt ojobnum)
(movem tt o2jobnum)
(popj p)
wrongj (movei a 'wrong-jobnum)
(popj p)
;;; Interrupt Defer
;;; Takes a char in TT and defers the interrupt
em:defer-interrupt
(exch t @ intpdl)
(push t ())
(tro tt #o400000)
(push t tt)
(push t ())
(push t ())
(movei tt edcnt)
(push t tt)
(push t d)
(push t r)
(push t f)
(exch t @ intpdl)
(jrst 0 @ chnint) ;go for it
edcnt (popj p)
;;; Mail Type
(entry em:process-mail subr)
em:process-mail
(entry em:mail-type subr)
(args em:mail-type (nil . 0))
em:mail-type
(setzm 0 explicit-eof) ;0 means nil
(setzm 0 forcedp)
(move tt (+ imailbox 1));type bits
(setzm 0 contp)
(tlne tt cont-bit)
(setom 0 contp)
(hrrzs 0 tt) ;grumble, test for range
(skipge 0 tt) ;too low?
(jrst 0 unknown) ;yup, unknown
(caile tt high-command) ;too high
(jrst 0 unknown)
(jrst 0 @ type-disp tt) ;dispatch
unknown (movei a 'unknown)
(popj p)
type-disp
(0 0 no-op)
(0 0 initiate)
(0 0 ok)
(0 0 sexps)
(0 0 explicit-eof)
(0 0 e-command)
(0 0 interrupt)
(0 0 kill)
(0 0 readonlyvars)
e-command
(movei a 'ecommand)
(popj p)
no-op
(movei a 'no-op)
(popj p)
sexps
(move a (+ imailbox 2)) ;get number of bytes
(move tt (+ imailbox 1)) ;type bits
(hlrem a inbytes) ;store it
(hlre b a) ;-number of bytes
(idivi b 4) ;-number of words
(jumpe c ztesch)
(subi b 1) ;one more, bunkie
ztesch
(movem b inwords)
(move b inpointtem)
(movem b inpoint)
(skipe 0 withinrov)
(setom 0 delayedsexp)
(setom 0 newwrcv) ;newwrcv fix.
; (setzm 0 mailinp)
(tlne tt short-bit) ;short?
(jrst 0 tshort)
(pushj p transfer-buffer)
(movei a 'sexps)
(popj p)
tshort (pushj p transfer-short)
(movei a 'sexps)
(popj p)
initiate(movei a 'initiate)
; (setzm 0 mailinp)
(popj p)
readonlyvars
(movei tt rovmail)
(movem tt transfer-spot)
(movei tt rovmailblksize)
(movem tt transfer-size)
(move a (+ imailbox 2)) ;number of bytes
(hlrem a rinbytes)
(movem a inwords)
(move a irovpointtem)
(movem a irovpoint)
; (setzm 0 mailinp)
(move tt (+ imailbox 1)) ;type bits
(tlne tt short-bit) ;short?
(jrst 0 rtshort)
(pushj p transfer-buffer)
(movei a 'readonlyvars)
(popj p)
rtshort (pushj p transfer-short)
(movei a 'readonlyvars)
(popj p)
interrupt
(move tt (+ imailbox 2))
(tro tt #o200) ;controlify it
(hlrz t noquit) ;Maclisp bug allowed this interrupt
(jumpn t mitr1)
(jsp t fxcons)
(call 1 'em:control-dispatch)
explicit-eof
(setom 0 explicit-eof)
(movei a 'eof)
(popj p)
ok
(movei a 'ok)
; (setzm 0 mailinp)
(popj p)
kill
(calli 1 12) ;kill self
;;; Wait Mail
(entry em:wait-mail subr)
(args em:wait-mail (nil . 0))
em:wait-mail
; (setzm 0 tyi-inited)
(setzm 0 lqp)
(skipe 0 tyop)
(pushj p force2)
wm6 (skipn 0 (special -em:queue-))
(jrst 0 wm7)
(movei t wm2)
(jrst 0 wm4)
wm7 (skipe 0 (special -em:mail-input-buffer-dry-handler-))
(pushj p em:call-handler)
wm1
(mail 1 imailbox) ;WRCV
wm2 (hlrz tt imailbox) ;get EPR half
(caie tt epr) ;is it EPR (in sixbit)?
(jrst 0 wm6)
(hrrz tt imailbox) ;get the jobnum
(skipg 0 ijobnum)
(pushj p setjob)
(came tt ijobnum) ;correct one?
(jrst 0 wm6)
wm3
; (setom 0 mailinp) ;mail now in
(movei a 't)
(popj p)
wm4 (movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(push fxp t)
(skipe 0 withinrov) ;inside read only hacker?
(jrst 0 wm9)
(call 0 'em:get-queue)
wm10 (pop fxp t)
(hrlz tt 0 a) ;address of mailbox
(hrri tt imailbox)
(blt tt (+ imailbox (- mlblksize 1))) ;transfer it
(move tt (+ imailbox 1))
(tlnn tt short-bit)
(pushj p wm8)
(setom 0 newwrcv)
; (setom 0 tyi-inited) ;ready to read
(hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(jrst 0 0 t)
wm9 (call 0 'em:get-readonly-queue) ;get first readonly message from queue
(pop fxp t)
(skipe 0 a) ;no such thing?
(movei t wm1) ;then we must wrcv it
(jrst 0 wm10) ;merge in after other type of queue
;(entry wm8 subr)
wm8 (pushj p zinmail)
(call 0 'em:get-lqueue)
(setom 0 lqp) ;got queued mail already
(move a 0 a)
(move b a)
(aos 0 a)
(hrlz tt a)
(hrri tt inmail)
(movn b 0 b)
(addi b inmail)
(sos 0 b)
(blt tt 0 b) ;transfer it
(popj p)
;;; Validate mail in tt, via jsp t
validate-mail
(push fxp tt)
; (pushj p pushtt1)
(hlrzs 0 tt)
(caie tt epr) ;is it EPR (in sixbit)?
(jrst 0 vm1)
(hrrz tt 0 fxp) ;get the jobnum
(camn tt ijobnum) ;correct one?
(aos 0 t)
vm1
(pop fxp tt)
; (pushj p poptt1)
(jrst 0 0 t)
;;; Mask Routines
(entry em:mask-off subr)
(args em:mask-off (nil . 0))
(aos 0 critical)
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:turn-mask-off subr)
(args em:turn-mask-off (nil . 0))
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:mask-on subr)
(args em:mask-on (nil . 0))
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(movei a 't)
(popj p)
em:call-handler
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(move a (special -em:mail-input-buffer-dry-handler-))
(callf 0 0 1)
(hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(skipn 0 delayedsexp)
(popj p)
(sub p (% 0 0 1 1))
(jrst 0 wm2)
;;; Mail SFA
(entry em:mail-sfa subr)
(args em:mail-sfa (nil . 3))
(movei a 0 b) ;operation type ignore the object
(caie a 'which-operations)
(jrst 0 t1)
(movei a '(tyi tyo force-output untyi charpos linel ;terpri
force-readonly-message send-lines report-send-lines
ttyint))
(popj p)
t1 (cain a 'tyi) ;tyi?
(jrst 0 em:mail-tyi)
(cain a 'tyo) ;tyo?
(jrst 0 em:mail-tyo)
(cain a 'force-output) ;force output?
(jrst 0 em:mail-force-output)
(cain a 'untyi) ;untyi?
(jrst 0 em:mail-untyi)
(cain a 'charpos)
(jrst 0 em:mail-charpos)
(cain a 'linel)
(jrst 0 em:mail-linel)
(cain a 'send-lines)
(jrst 0 isend-lines)
(cain a 'report-send-lines)
(jrst 0 report-send-lines)
(cain a 'force-readonly-message)
(jrst 0 em:force-readonly-message)
(cain a 'ttyint)
(jrst 0 em:ttyint1)
(movei a 'nil)
(popj p)
(entry em:mail-charpos subr)
(args em:mail-charpos (nil . 0))
em:mail-charpos
(skipn 0 c)
(jrst 0 g2)
(hrrz a c)
(move c 0 a)
(movem c charpos)
(popj p)
g2 (move tt charpos)
(jrst 0 fix1)
em:mail-linel
(skipn 0 c)
(jrst 0 g3)
(hlrz a 0 c)
(movem a (special -em:linel-))
(popj p)
g3 (move a (special -em:linel-))
(popj p)
isend-lines
(movem c send-lines)
(move c @ c)
(movem c skipp)
(movem c vsend-lines)
(movei a 't)
(popj p)
report-send-lines
(move a send-lines)
(popj p)
(entry em:init-send-lines subr)
(args em:init-send-lines (nil . 0))
(movei a noutbytes)
(movem a outbytes)
(movei a nrovbytes)
(movem a rovbytes)
(movei tt 0)
(movem tt vsend-lines)
(movem tt skipp)
(movei a 'NIL)
(movem a send-lines)
(popj p)
em:terpri
(setzm 0 forcedp)
(setom 0 tyop)
(movei a cr)
(pushj p tyo1)
(movei a lf)
(jrst 0 tyo1)
em:ttyint1
(move a c)
(jcall 1 'em:ttyint)
;;; Tyi
(entry em:mail-tyi subr)
em:mail-tyi
(skipe 0 explicit-eof)
(jrst 0 eeof)
(movem c eofchar)
(skipe 0 untyif)
(jrst 0 untyi2)
; (skipn 0 tyi-inited) ;not inited?
; (pushj p real-mail-refresh)
ityi (skipe 0 inbytes) ;and nothing left?
(jrst 0 tyi1)
(skipe 0 (special -em:filemode-)) ;in special file mode?
(jrst 0 reof)
tyi2 (pushj p mail-refresh)
tyi1 (aosle 0 inbytes)
(pushj p mail-refresh)
inmailok
(setzm 0 newwrcv)
(ildb tt inpoint) ;get byte
(trne tt cntrl-bit)
(jrst 0 pondercntrl)
(jrst 0 fix1) ;what a bum!
em:mail-untyi
(aos 0 untyif)
(move b untyipdl)
(push b c)
(movem b untyipdl)
(popj p)
untyi2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
eeof (setzm 0 explicit-eof)
reof
(move a eofchar)
(sub p (% 0 0 1 1))
(popj p)
pondercntrl
(trnn tt meta-bit) ;foo it was control-meta
(jrst 0 tyi3)
(jrst 0 fix1) ;what a bum!
tyi3 (caie tt ccntrlg) ;↑G
(cain tt cntrlg) ;↑g
(jrst 0 ↑Ghandler)
(caie tt ccntrlx) ;↑X
(cain tt cntrlx) ;↑x
(jrst 0 ↑Xhandler)
(movei tt 0 tt)
(jsp t fxcons)
(jcall 1 'em:control-dispatch)
(popj p)
↑Xhandler
(movei t em:mail-tyi)
(push p t)
(push p (% 0 0 'quit))
(movni t 1)
(jcall 16 'error)
↑Ghandler
(pushj p em:init)
(call 0 '↑G)
(entry em:messagep subr)
; (skipe 0 tyi-inited)
(skipge 0 inbytes)
(jrst 0 true)
(skipe 0 (special -em:queue-))
(jrst 0 true)
(mail 3)
(jrst 0 false)
(jrst 0 true)
;;; Tyo
(entry em:mail-tyo subr)
em:mail-tyo
(skipe 0 (special ↑W))
(popj p)
(setzm 0 forcedp)
(setom 0 tyop)
(move a @ c)
(caie a cr)
(cain a lf)
(skipa)
(setom 0 noncrlf) ;means a non crlf char has been sent
tyo1 (pushj p ucharpos) ;update charpos
(idpb a outpoint) ;put it there
(sosg 0 outbytes) ;ready to send?
(pushj p cmail-sendit)
(caie a lf)
(jrst 0 linelforce)
forceit
(skipn 0 noncrlf)
(jrst 0 true) ;only crlf's so far
(skipn 0 send-lines) ;if T then just return
(jrst 0 fmail-sendit)
(movei tt 't)
(camn tt send-lines)
(jrst 0 true)
(sosle 0 skipp) ;ready to do it?
(jrst 0 true)
(jrst 0 fmail-sendit)
;;; special entry for Refresh case only
force2 (skipe 0 send-lines) ;if T then just return
(popj p)
(jrst 0 fmail-sendit)
ucharpos
(caie a cr) ;cr
(jrst 0 uchrp1)
(setzm 0 charpos)
(popj p)
uchrp1 (cain a bs)
(jrst 0 adjstbs)
(cain a tab) ;tab
(jrst 0 adjstab)
(aos 0 charpos)
(popj p)
adjstab (move tt charpos)
(idivi tt 8.)
(aos 0 tt)
(imuli tt 8.)
(movem tt charpos)
(popj p)
adjstbs (aos 0 charpos)
(popj p)
linelforce
(caie a #o40) ;space?
(cain a #o11) ;tab?
(skipa)
(jrst 0 true)
(move tt charpos)
(camg tt @ (special -em:linel-))
(jrst 0 true)
(movei a #o15)
(pushj p ucharpos) ;update charpos
(idpb a outpoint) ;put it there
(sosg 0 outbytes) ;ready to send?
(pushj p cmail-sendit)
(movei a #o12)
(jrst 0 tyo1)
;;; Force Output
fmail-sendit
(setom 0 forcedp)
(setz b)
(jrst 0 mail-sendit)
cmail-sendit
(movei b cont-bit)
(jrst 0 mail-sendit)
em:mail-force-output
(entry em:mail-force-output subr)
(skipe 0 forcedp)
(jrst 0 true)
(setz b) ;continuation
mail-sendit
(aos 0 critical)
(722←33 0 mailint) ;imskcl
(setzm 0 noncrlf)
(setzm 0 charpos)
(setzm 0 tyop)
(move a vsend-lines)
(movem a skipp)
(setz t)
(skipe 0 (special -em:silence-))
(jrst 0 skipit)
(hrlzi a omailbox)
(hrri a (+ omailbox 1))
(setzm 0 omailbox)
(blt a (+ omailbox (- mlblksize 1))) ;zero it
(movei a noutbytes)
(sub a outbytes)
(movei t 1) ;1 in t means long
(caile a maxshort) ;short enough
(jrst 0 send-message) ;nope
(setz t) ;0 in T means short
(hrlzi tt outmail)
(hrri tt (+ omailbox 3))
(blt tt (+ omailbox (- mlblksize 1))) ;move to the right place
(iori b short-bit)
send-message
(hrl tt b) ;swap
(hrri tt sexp-type)
(skipe 0 (special -em:ecommands-))
(hrri tt ecommand-type)
(movem tt (+ omailbox 1))
(movns 0 a)
(hrlzm a (+ omailbox 2))
(movei a outmail)
(hrrm a (+ omailbox 2))
(move a thisjob)
(hrli a epr) ;epr validation
(movem a omailbox)
(movem t sav)
(mail 3) ;shit, mail arrived and it might be long!
(mail 5 ojobnum) ;mail it
(jsp tt wait-for-clear)
(move t sav)
skipit (setzm 0 (special -em:silence-))
(move a outpointtem) ;setup output byte count
(movem a outpoint)
(movei a noutbytes)
(movem a outbytes)
(jumpe t sm2) ;don't hang around
(pushj p wait-ok) ;wait for acknowledgment
sm2 (hrlzi a outmail)
(hrri a (+ outmail 1))
(setzm 0 outmail)
(blt a (+ outmail (- rdblk 1))) ;zero it
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(jrst 0 true)
;;; Message Align
;;; Gets to the beginning of the next message
(entry em:message-align subr)
(args em:message-align (nil . 0))
em:message-align
(skipe 0 newwrcv)
(jrst 0 true)
(pushj p mail-refresh)
(jrst 0 true)
;;; The following has been flushed:
;;; -----------------------------------------------------------
;;; Routine to get to a buffer from E with not all <cr>s in it
;(entry em:crlf-message-align subr)
;(args em:crlf-message-align (nil . 0))
;em:crlf-message-align
;
; (skipe 0 newwrcv)
; (jrst 0 true)
; (move tt inpoint) ;copy of byte pointer
; (move t inbytes)
; (skipe 0 untyif) ;stuff on the untyi stack?
; (jrst 0 filalun) ;foo, there is.
;filalgn2
; (aosle 0 t)
; (jrst 0 filalgn1)
; (setzm 0 newwrcv)
; (ildb a tt)
; (skipn 0 a)
; (jrst 0 alnxtx)
; (caie a tab)
; (cain a space)
; (jrst 0 alnxtx)
; (caie a cr) ;a cr?
; (cain a lf) ;a lf?
; (skipa)
; (jrst 0 true)
;
;alnxtx (ibp 0 inpoint)
; (aos 0 inbytes)
; (jrst 0 filalgn2)
;filalgn1
; (pushj p mail-refresh)
; (jrst 0 true)
;
;filalun (move r untyipdl)
; (move f untyif)
;filalu1 (sosge 0 f)
; (jrst 0 filalgn2)
; (pop r a)
; (move a 0 a)
; (caie a tab)
; (cain a space)
; (jrst 0 filxtx)
; (caie a cr) ;a cr?
; (cain a lf) ;a lf?
; (skipa)
; (jrst 0 true)
;
;filxtx (movem r untyipdl)
; (movem f untyif)
; (jrst 0 filalu1)
;;; Mail Refresh
;;; This routine gets fresh mail to initialize the reader
mail-refresh
real-mail-refresh
(aos 0 critical)
(722←33 0 mailint) ;imskcl
mr2
mr3 (pushj p em:wait-mail) ;wait for response
(pushj p em:process-mail) ;get the mail
(caie a 'sexps)
(jrst 0 mr3)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
;;; Transfer Buffer
;;; This routine does a jobread into the right spot.
;(entry tb subr)
transfer-buffer
(skipe 0 lqp) ;queued mail read already?
(jrst 0 tb1)
(skipe 0 (special -em:queue-))
(jrst 0 queue-stuff)
; (setom 0 tyi-inited) ;ready to read
(move a transfer-spot)
(hrrzm a (+ jobread 2))
(pushj p zinmail)
(move a (+ imailbox 2))
(hrl a inwords)
(movem a (+ jobread 1))
(movei tt jobread)
(calli tt 400050) ;jobrd
(jrst 0 fjobrd)
(aos 0 critical)
(722←33 0 mailint) ;imskcl
(pushj p send-ok)
(setzm 0 lqp)
(skipe 0 contp)
(jrst 0 queue-stuff2)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
tb1 (setzm 0 lqp)
(popj p)
transfer-short
(pushj p zinmail)
(hrlzi a (+ imailbox 3)) ;move from here
(hrr a transfer-spot) ;to here
(move tt transfer-spot)
(addi tt (- mlblksize 1))
(blt a 0 tt) ;transfer 29
; (setom 0 tyi-inited) ;ready to read
; (setzm 0 lqp)
(popj p)
zinmail
(hrlz a transfer-spot)
(move tt transfer-spot)
(aos 0 tt)
(hrr a tt)
(setzm 0 @ transfer-spot)
(move tt transfer-spot)
(add tt transfer-size)
(blt a -1 tt)
(popj p)
;(entry qs subr)
queue-stuff
(aos 0 critical)
(722←33 0 mailint) ;imskcl
queue-stuff2
(push fxp tt)
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
zt4
(call 0 'em:add-queue)
(hrrz tt 0 a) ;address of mailbox
; (skipn 0 mailinp) ;already wrcv'd it?
; (jrst 0 zt5)
; (movei tt imailbox)
; (jrst 0 zt9)
zt5
(mail 1 0 tt) ;get mail
zt9 (push fxp tt)
(move tt 0 tt)
(jsp t validate-mail)
(jrst 0 zt6)
(pop fxp tt)
(move t 1 tt) ;type bits
(cain t interrupt-type) ;can have no long type
(jrst 0 punt1)
(cain t kill-type) ;can have no long type
(calli 1 12) ;kill self
(push fxp t)
(movei t 0 t) ;foo, what if it's long!
(caie t sexp-type)
(jrst 0 zt0)
(move t 0 fxp)
; (setzm 0 lqp)
(tlnn t short-bit) ;short?
(pushj p enqueue-buffer)
(pop fxp t)
(setzm 0 contp)
(tlze t cont-bit)
(jrst 0 zt7)
; (setom 0 lqp)
(jrst 0 zt8)
zt6 (pop fxp tt)
(jrst 0 zt5)
zt7 (setom 0 contp)
(movem t 1 tt)
(jrst 0 zt4)
zt0 (pop fxp t)
zt8 (hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(pop fxp tt)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
;(entry eb subr)
enqueue-buffer
(push fxp tt)
(hrrz tt 0 fxp)
(move a 2 tt) ;address in E of buffer
(hrrzm a (+ ljobread 1))
(hlre tt a) ;-number of bytes
(idivi tt 4) ;-number of words
(jumpe d zt1)
(subi tt 1) ;one more, bunkie
zt1
(hrlm tt (+ ljobread 1))
(movns 0 tt)
(jsp t fxcons)
(call 1 'em:add-lqueue)
(hrrz a 0 a) ;address of mailbox
(hlre tt (+ ljobread 1))
(movem tt 0 a)
(aos 0 a)
(hrrzm a (+ ljobread 2))
(movei tt ljobread)
(calli tt 400050) ;jobrd
(jrst 0 pfxpfalse)
(pop fxp tt)
(jrst 0 send-ok)
punt1 (setzm 0 1 tt)
(move d t)
(add fxp (% 0 0 4 4)) ;adjust stack in obscure manner
(pushj p procint)
(mail 3)
(skipa)
(jrst 0 zt4)
(pop fxp tt)
(jrst 0 zt8)
;;; Clear Input
(entry em:clear-input subr)
(args em:clear-input (nil . 0))
(setzm 0 lqp)
(setzm 0 critical)
(setzm 0 tyop)
(setzm 0 forcedp)
(setzm 0 noncrlf)
(setzm 0 untyif)
(setzm 0 inbytes)
(movei a 1)
(movem 1 rinbytes)
(move a temuntyipdl)
(movem a untyipdl)
(setom 0 explicit-eof)
; (setzm 0 mailinp)
; (setzm 0 tyi-inited)
(pushj p zinmail)
(movei a 't)
(popj p)
;;; Wait OK
;(entry wait-ok subr)
wait-ok
(aos 0 critical)
(722←33 0 mailint) ;imskcl
wo2 (mail 1 imailbox) ;WRCV
(move tt (+ imailbox 1))
(hrrzs 0 tt) ;flush short?
(caie tt ok-type)
(jrst 0 wo1)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(jrst 0 true)
wo1
(push fxp tt)
(movem freeac (+ svdacs 9.))
(movei freeac svdacs)
(hrli freeac b)
(blt freeac (+ svdacs 9.))
(setz b)
(movei freeac c)
(hrli freeac b)
(blt freeac freeac)
(call 0 'em:add-queue)
(move a 0 a)
(move tt a)
(hrli a imailbox)
(move b tt)
(addi b (- mlblksize 1))
(blt a 0 b)
(jrst 0 zt19)
zt14 (call 0 'em:add-queue)
(hrrz tt 0 a) ;address of mailbox
zt15 ;(mail 2 0 tt) ;mail here so soon?
(mail 1 0 tt) ;get mail
(push fxp tt)
(move tt 0 tt)
(jsp t validate-mail)
(jrst 0 zt16)
(pop fxp tt)
zt19 (move t 1 tt) ;type bits
(cain t interrupt-type)
(jrst 0 punt2)
(cain t kill-type)
(calli 1 12)
(push fxp t)
(movei t 0 t)
(caie t sexp-type)
(jrst 0 zt00)
(move t 0 fxp)
; (setzm 0 lqp)
(tlnn t short-bit) ;short?
(pushj p enqueue-buffer)
(pop fxp t)
(setzm 0 contp)
(tlze t cont-bit)
(jrst 0 zt17)
; (setom 0 lqp)
(jrst 0 zt14)
zt16 (pop fxp tt)
(jrst 0 zt14)
zt17 (setom 0 contp)
(movem t 1 tt)
(jrst 0 zt14)
zt00 (pop fxp t)
zt18 (hrlzi freeac svdacs)
(hrri freeac b)
(blt freeac freeac)
(pop fxp tt)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(jrst 0 true)
punt2 (setzm 0 1 tt)
(move d t)
(add fxp (% 0 0 4 4)) ;adjust stack in obscure manner
(pushj p procint)
(mail 3)
(skipa)
(jrst 0 zt14)
(pop fxp tt)
(jrst 0 zt18)
;;; Send Simple Message
(entry em:send-simple-message subr)
(args em:send-simple-message (nil . 1))
(cain a 'ok)
(jrst 0 ok-message)
(cain a 'initiate)
(jrst 0 initiate-message)
(cain a 'hold-it)
(jrst 0 hold-it-message)
(cain a 'eof)
(jrst 0 eof-message)
(movei a 'Invalid-message)
(popj p)
eof-message
(movei a explicit-eof-type)
(jrst 0 send-simple-message)
initiate-message
(movei a initiate-type)
(jrst 0 send-simple-message)
ok-message
(movei a ok-type)
(jrst 0 send-simple-message)
hold-it-message
(movei a 102)
(movem a (+ omailbox 2))
(movei a interrupt-type)
send-simple-message
(movem a (+ omailbox 1))
(move b thisjob)
(hrli b epr)
(movem b omailbox)
(jfcl)
(mail 5 ojobnum)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
; (entry wfc subr)
wait-for-clear
(mail 3)
(jrst 0 wfc1) ;nothing there?
(aos 0 critical)
(722←33 0 mailint)
(pushj p queue-stuff2)
wfc1 (setz a)
(calli a 31)
(jrst 0 -3 tt)
gobble-stuff
(mail 3)
(popj p) ;nothing there?
(aos 0 critical)
(722←33 0 mailint)
(pushj p queue-stuff2)
gbst1 (setz a)
(calli a 31)
(jrst 0 gobble-stuff)
;;; Em:init
(entry em:init subr)
(args em:init (nil . 0))
em:init
(movei a '(features paging))
(call 17 'status)
(jumpe a in1)
(movei a #o65126)
(movem a chnint)
(movei a #o2201)
(movem a intpdl)
(jrst 0 in2)
in1 (movei a #o456006)
(movem a chnint)
(movei a @ #o125)
(hrrz a 0 a)
(movem a intpdl)
in2 (setzm 0 (special -em:queue-))
(setzm 0 (special -em:lqueue-))
(setzm 0 inbytes)
(setzm 0 tyop)
(movei a 1)
(movem a rinbytes)
(setzm 0 lqp)
(setzm 0 newwrcv)
(setzm 0 critical)
(setzm 0 withinrov)
(setzm 0 delayedsexp)
(movei tt inmail)
(movem tt transfer-spot)
(movei tt blksize)
(movem tt transfer-size)
(movei tt noutbytes)
(movem tt outbytes)
(movei tt nrovbytes)
(movem tt rovbytes)
(move tt inpointtem)
(movem tt inpoint)
(move tt outpointtem)
(movem tt outpoint)
(pushj p zinmail)
(calli tt #o30)
(movem tt thisjob)
(jrst 0 fix1)
em:get-terminal
(movei tt #o236)
(calli tt #o33) ;jobtlin
(add tt ijobnum) ;add jobnum
(calli tt #o33) ;get terminal line number
(hrrzm tt termlin) ;save it
(popj p)
(entry em:warn subr)
(args em:warn (nil . 1))
(call 1 'exploden)
(movei tt 500.)
(move t mpointtem)
(move a 0 a)
wloop (hlrz b a)
(move b 0 b)
(idpb b t)
(sosge 0 tt)
(jrst 0 wdone)
(skipn 0 b)
(jrst 0 wdone)
(move a 0 a)
(jrst 0 wloop)
wdone
(movei a dmess)
sendmess
(move tt termlin)
(calli tt #o400111) ;beep it
(movem a (+ termlin 1))
(movei tt termlin)
(calli tt #o400047)
(jrst 0 false)
(jrst 0 true)
(entry em:copy-alias1 subr)
(args em:copy-alias1 (nil . 0))
(move tt (special si:ejobnum))
(calli tt #o400071) ;dskppn
(calli tt #o400071)
(push fxp tt)
(hrlzs 0 tt)
(pushj p sixatm)
(jsp t %ncons)
(push p a)
(pop fxp tt)
(hllzs 0 tt)
(pushj p sixatm)
(pop p b)
(jsp t %cons)
(popj p)
;;; Send OK
send-ok
(movei a ok-type)
(movem a (+ o2mailbox 1))
(move b thisjob)
(hrli b epr)
(movem b o2mailbox)
(jfcl)
(mail 5 o2jobnum)
(jsp tt wait-for-clear)
(jrst 0 true)
(jrst 0 false)
;;; Em:eval-protect
(entry em:eval-protect subr)
(args em:eval-protect (nil . 0))
(movei a 'em:sail-mail-interrupt-handler)
(movem a (special si:sail-mail-service))
(movei a 't)
(popj p)
(entry em:eval-unprotect subr)
(args em:eval-unprotect (nil . 0))
(movei a 'nil)
(movem a (special si:sail-mail-service))
(popj p)
(entry em:critical-depth subr)
(args em:critical-depth (nil . 0))
(move tt critical)
(jrst 0 fix1)
;;; Mail queue
(entry em:business-address subr)
(args em:business-address (nil . 1))
(hrrz a 0 a) ;get address
(hrrz tt 0 a)
(hrrzi tt 4 tt) ;business address
(jrst 0 fix1) ;return it
(entry em:message-type subr)
(args em:message-type (nil . 1))
(hrrz a 0 a) ;get address
(hrrz tt 0 a)
(hrrz tt 5 tt) ;business address
(move a types tt)
(popj p) ;return it
(entry em:mail-interrupt-handler subr)
(args em:mail-interrupt-handler (nil . 1))
(aos 0 critical)
(722←33 0 mailint) ;imskcl
; (mail 3)
; (jrst 0 uncriticalfalse)
(push fxp tt)
(push fxp t)
(push fxp d)
mi4 (call 0 'em:add-queue)
(hrrz tt 0 a) ;address of mailbox
mi5 (mail 1 0 tt) ;get mail
(push fxp tt)
(move tt 0 tt)
(jsp t validate-mail)
(jrst 0 mi6)
(pop fxp tt)
(move t 1 tt) ;type bits
(cain t interrupt-type)
(jrst 0 mi8)
(cain t kill-type)
(calli 1 12) ;suicide
(push fxp t)
; (setzm 0 lqp)
(tlnn t short-bit) ;short?
(pushj p enqueue-buffer)
(pop fxp t)
(setzm 0 contp)
(tlze t cont-bit)
(jrst 0 mi7)
; (setom 0 lqp)
(jrst 0 mi8)
mi6 (pop fxp tt)
(jrst 0 mi5)
mi7 (setom 0 contp)
(movem t 1 tt)
(jrst 0 mi4)
mi8 (hrrz d 1 tt) ;type
(sosg 0 critical)
(721←33 0 mailint) ;imskst
procint
(cain d kill-type)
(calli 1 12) ;suicide
(caie d interrupt-type) ;control char?
(jrst 0 mitrue) ;no, just report the incident
(trne d meta-bit)
(jrst 0 mitrue)
(sub fxp (% 0 0 3 3)) ;baz pop those guys
(push fxp tt)
(call 0 'em:remove-tail)
(skipe 0 withinrov)
(pushj p rovuninit)
(pop fxp tt)
(move tt 2 tt)
(tro tt #o200) ;controlify it
(hlrz t noquit) ;Maclisp bug allowed this interrupt
(jumpn t mitr1)
(jsp t fxcons)
(jcall 1 'em:control-dispatch)
mitr1 (pushj p em:defer-interrupt)
(jrst 0 true)
mitrue
(pop fxp d)
(pop fxp t)
(pop fxp tt)
(jrst 0 true)
uncriticalfalse
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(jrst 0 false)
;;; Readonly Variables
;;; Routines for obtaining the values of readonly variables
(entry em:readonly-init subr)
(args em:readonly-init (nil . 0))
(aos 0 critical)
(722←33 0 mailint) ;imskcl
;inited mailinp
;0 0 ?
;0 -1 in but not inited, must refresh
;-1 0 ok
;-1 -1 contradiction
(pushj p gobble-stuff) ;all clear
(setom 0 withinrov)
(move tt tyop)
(movem tt otyop)
; (move tt tyi-inited)
; (movem tt otyi-inited)
(move tt transfer-spot)
(movem tt otransfer-spot)
(move tt transfer-size)
(movem tt otransfer-size)
(setzm 0 tyop)
(jrst 0 true)
(entry em:make-sixbit subr)
(args em:make-sixbit (nil . 1))
;;; Takes list of variables and returns an alist of variable-value pairs
sixmak (movei b '6) ;direct lift from faslap
(call 2 'pnget)
(hlrz a 0 a)
(move tt 0 a)
(idpb tt rovpoint) ;put it there
(sosle 0 rovbytes) ;ready to send?
(jrst 0 fix1) ;return fixnum
;falls through
;;; Read only variable mail message
(entry em:force-readonly-message subr)
(args em:force-readonly-message (nil . 0))
em:force-readonly-message
; (setzm 0 tyi-inited)
(movei a rovmail) ;address of buffer
(movem a (+ omailbox 2))
(movei a nrovbytes)
(sub a rovbytes)
(movei t 1) ;1 in t means long
(caile a rovmaxshort) ;short enough
(jrst 0 rovsend-message) ;nope
(setz t) ;0 in T means short
(hrlzi tt rovmail)
(hrri tt (+ omailbox 3))
(blt tt (+ omailbox (- mlblksize 1))) ;move to the right place
(iori b short-bit)
rovsend-message
(hrl tt b) ;swap
(hrri tt readonlyvar-type)
(movem tt (+ omailbox 1))
(movns 0 a)
(hrlzm a (+ omailbox 2))
(movei a rovmail)
(hrrm a (+ omailbox 2))
(move a thisjob)
(hrli a epr) ;epr validation
(movem a omailbox)
(mail 3)
(mail 5 ojobnum) ;mail it
(jsp tt wait-for-clear)
(skipa)
(jrst 0 wrongj)
(hrlzi a rovmail) ;zeros output buffer
(hrri a (+ rovmail 1))
(setzm 0 rovmail)
(blt a (+ rovmail (- rovmailblksize 1))) ;zero it
(move a rovpointtem) ;setup output byte count
(movem a rovpoint)
(movei a 1)
(movem a rinbytes)
(movei a nrovbytes)
(movem a rovbytes)
(jumpe t true) ;don't hang around
(pushj p wait-ok) ;wait for acknowledgment
(pushj p em:mail-type)
(came a 'ok)
(jrst 0 false)
(jrst 0 true)
(entry em:get-next-readonly subr)
(args em:get-next-readonly (nil . 0))
; (skipn 0 tyi-inited)
(skiple 0 rinbytes)
(pushj p rovmail-refresh)
(aosle 0 rinbytes)
(jrst 0 rovdone)
(ildb tt irovpoint) ;get it
(jsp t fxcons)
(push fxp a) ;save it
(aosle 0 rinbytes)
(jrst 0 (- rovdone 1))
(ildb tt irovpoint)
(jsp t fxcons)
(pop fxp b)
(jcall 2 'xcons)
(sub fxp (% 0 0 1 1))
rovdone
; (move tt otyi-inited)
; (movem tt tyi-inited)
(pushj p rovuninit)
(seto tt)
(jrst 0 fix1)
rovuninit
(move tt otransfer-spot)
(movem tt transfer-spot)
(move tt otransfer-size)
(movem tt transfer-size)
(move tt otyop)
(movem tt tyop)
(setzm 0 withinrov)
(sosg 0 critical)
(721←33 0 mailint) ;imskst
(popj p)
rovmail-refresh
rm2 (pushj p em:wait-mail)
(pushj p em:process-mail)
(cain a 'readonlyvars)
(popj p)
(jrst 0 rm2)
;;; Random debugging stuff
;;; Prints the char on FXP with outchr
;pushtt1
; (push fxp tt)
; (movei tt 101)
; (ttyuuo 1 tt)
; (aos 0 ptt1)
; (move tt 0 fxp)
; (popj p)
;poptt1
; (movei tt 141)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt1)
; (popj p)
;pushtt2
; (push fxp tt)
; (movei tt 102)
; (ttyuuo 1 tt)
; (aos 0 ptt2)
; (move tt 0 fxp)
; (popj p)
;poptt2
; (movei tt 142)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt2)
; (popj p)
;pushtt3
; (push fxp tt)
; (movei tt 103)
; (ttyuuo 1 tt)
; (aos 0 ptt3)
; (move tt 0 fxp)
; (popj p)
;poptt3
; (movei tt 143)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt3)
; (popj p)
;pushtt4
; (push fxp tt)
; (movei tt 104)
; (ttyuuo 1 tt)
; (aos 0 ptt4)
; (move tt 0 fxp)
; (popj p)
;poptt4
; (movei tt 144)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt4)
; (popj p)
;pushtt5
; (push fxp tt)
; (movei tt 105)
; (ttyuuo 1 tt)
; (aos 0 ptt5)
; (move tt 0 fxp)
; (popj p)
;poptt5
; (movei tt 145)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt5)
; (popj p)
;pushtt6
; (push fxp tt)
; (movei tt 106)
; (ttyuuo 1 tt)
; (aos 0 ptt6)
; (move tt 0 fxp)
; (popj p)
;poptt6
; (movei tt 146)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt6)
; (popj p)
;pushtt7
; (push fxp tt)
; (movei tt 107)
; (ttyuuo 1 tt)
; (aos 0 ptt7)
; (move tt 0 fxp)
; (popj p)
;poptt7
; (movei tt 147)
; (ttyuuo 1 tt)
; (pop fxp tt)
; (sos 0 ptt7)
; (popj p)
;popt
; (movei t 22)
; (ttyuuo 1 t)
; (pop fxp t)
; (sos 0 pt)
; (popj p)
;ptt1 (0)
;ptt2 (0)
;ptt3 (0)
;ptt4 (0)
;ptt5 (0)
;ptt6 (0)
;ptt7 (0)
;pt (0)
;;report
; (movem tt sav)
; (pop fxp tt)
; (ttyuuo 1 tt)
; (move tt sav)
; (popj p)
sav (0)
;;; Storage for Mail routines
types (0 0 'no-op)
(0 0 'initiate)
(0 0 'ok)
(0 0 'sexps)
(0 0 'explicit-eof)
(0 0 'e-command)
(0 0 'interrupt)
(0 0 'kill)
(0 0 'readonlyvars)
chnint (0)
intpdl (0)
critical (0)
delayedsexp (0) ;states whether an sexpr came in during
;an input buffer dry demon execution
newwrcv (0) ;is not 0 when a WRCV has been done without any
;ilbp being done (sexps only)
lqp (0) ;queued long mail read
contp (0) ;continuation bit
withinrov (0)
transfer-spot (0)
otransfer-spot (0)
transfer-size (0)
otransfer-size (0)
svdacs (block 10.)
send-lines (0)
noncrlf (0)
vsend-lines (0)
skipp (0)
tyop (0)
otyop (0)
forcedp (0) ;output already forced
inwords (0) ;number of words to input via jobread
explicit-eof (-1) ;nil
mailint (4000000000)
ijobnum (-1)
(0 0 imailbox)
ojobnum (-1)
(0 0 omailbox)
o2jobnum(-1)
(0 0 o2mailbox)
imailbox (block mlblksize) ;mail
omailbox (block mlblksize) ;mail
o2mailbox (block mlblksize) ;mail
inmail (block blksize) ;text
outmail (block blksize) ;text
rovmail (block rovmailblksize)
stack (block 20)
untyipdl (777760←22 0 stack)
temuntyipdl (777760←22 0 stack)
untyif (0)
jobrderr (0)
jobrderrdispatch (0 0 jobrdem1)
(0 0 jobrdem2)
(0 0 jobrdem3)
(0 0 jobrdem4)
(0 0 jobrdem5)
(0 0 jobrdem6)
jobrdem1 (ascii | job not logged in|)(0)
jobrdem2 (ascii | ambiguous job name|)(0)
jobrdem3 (ascii | non-ex job name|)(0)
jobrdem4 (ascii | addr out of bounds|)(0)
jobrdem5 (ascii | job not logged in|)(0)
jobrdem6 (ascii | block too large|)(0)
jobrdem7 (ascii |
Perhaps you Swapped to E from Checksum?
|)(0)
jobrdmess1
(ascii |Communication Failed! (Transfer Buffer)|)
(0)
jobrdmess2
(ascii |Communication Failed! (Interrupt Level)|)
(0)
noquitmess (ascii |Interrupt during GC!|)
(0)
termlin (0)
(0 0 dmess)
dmess (block 100.)
(0)
mpointtem (700←22 0 (- dmess 1))
inpoint (1100←22 0 (- inmail 1))
inpointtem (1100←22 0 (- inmail 1))
irovpoint (4400←22 0 (- rovmail 1))
irovpointtem (4400←22 0 (- rovmail 1))
rinbytes (1)
inbytes (0)
outpoint (700←22 0 (- outmail 1))
outpointtem (700←22 0 (- outmail 1))
rovpoint (4400←22 0 (- rovmail 1))
rovpointtem (4400←22 0 (- rovmail 1))
outchartem (700←22 0 (+ omailbox 2))
outbytes (0 0 noutbytes)
rovbytes (0 0 nrovbytes)
;mailinp (0) ;-1 means in (newwrcv and this go on the same time, newwrcv goes
; off earlier)
mthree (-3)
charpos (0)
thisjob (0)
;tyi-inited (0) ;ready to read. 0 = nil, -1 = t (meaning buffer pointers inited)
;otyi-inited (0) ;ready to read. 0 = nil, -1 = t
eofchar (0) ;eof char
jobread (0)
(0)
(0 0 inmail)
ljobread(0)
(0)
(0 0 inmail)
()
(or (and (boundp 'em:no-init) em:no-init)
(progn
(em:mail-interface-initialize)))